home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / cond.t < prev    next >
Text File  |  1988-05-02  |  6KB  |  135 lines
  1. (herald cond (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; conditional macros
  27.  
  28. (define-safe-syntax (cond . clauses)
  29.                     (+ (+ #f))
  30.   (labels (((expand-cond clauses)
  31.             (cond ((atom? clauses) 'no-more-cond-clauses)
  32.                   ((atom? (car clauses))
  33.                    (syntax-error "atomic ~s clause: ~s" 'cond (car clauses)))
  34.                   ((atom? (cdar clauses))
  35.                    `(,(t-syntax 'or) ,(caar clauses)
  36.                                      ,(expand-cond (cdr clauses))))
  37.                   ((eq? (cadar clauses) '=>)
  38.                    `(cond-=>-aux ,(caar clauses)
  39.                                  (,(t-syntax 'lambda) ()
  40.                                    ,(caddr (car clauses)))
  41.                                  (,(t-syntax 'lambda) ()
  42.                                    ,(expand-cond (cdr clauses)))))
  43.                   (else `(,(t-syntax 'if) ,(caar clauses)
  44.                              ,(blockify (cdar clauses))
  45.                              ,(expand-cond (cdr clauses)))))))
  46.     (expand-cond clauses)))
  47.  
  48. (define-safe-syntax (xcond . clauses)
  49.                     (+ (+ #f))   ;++ doesn't check for ELSE
  50.   `(,(t-syntax 'cond) ,@clauses (else (no-op (losing-xcond)))))
  51.  
  52. (define-syntax (or . args)
  53.   (labels (((expand-or args)
  54.             (cond ((atom? args) ''#f)
  55.                   ((atom? (cdr args)) (car args))
  56.                   (else `(or-aux ,(car args)
  57.                                  (,(t-syntax 'lambda) ()
  58.                                        ,(expand-or (cdr args))))))))
  59.     (expand-or args)))
  60.  
  61. (define-syntax (and . args)
  62.   (labels (((expand-and args)
  63.             (cond ((atom? args) ''#t)
  64.                   ((atom? (cdr args)) (car args))
  65.                   (else `(,(t-syntax 'if) ,(car args)
  66.                                           ,(expand-and (cdr args))
  67.                                           '#f)))))
  68.     (expand-and args)))
  69.  
  70.  
  71. (define-safe-syntax (case key . clauses)
  72.                     (#f . (+ ((| (+ atom?) (! else)) . (* #f))))
  73.   (labels (((expand-case-1 keyvar clauses)
  74.             (if (atom? clauses)
  75.                 'case-fell-off-end
  76.                 (let ((clause (car clauses))
  77.                       (lose (lambda ()
  78.                               (syntax-error "bad ~s clause syntax: ~s"
  79.                                             'case
  80.                                             (car clauses)))))
  81.                   (cond ((atom? clause) (lose))
  82.                         ((list? (car clause))
  83.                          `(,(t-syntax 'if)
  84.                             (,(t-syntax 'or)
  85.                               ,@(map (lambda (k) `(eq? ,keyvar ',k)) ; equiv?
  86.                                      (car clause)))
  87.                             ,(blockify (cdr clause))
  88.                             ,(expand-case-1 keyvar (cdr clauses))))
  89.                         ((eq? (car clause) 'else) (blockify (cdr clause)))
  90.                         (else (lose)))))))
  91.           (let ((keyvar (generate-symbol 'case)))
  92.             `((,(t-syntax 'lambda) (,keyvar)
  93.                 ,(expand-case-1 keyvar clauses))
  94.               ,key))))
  95.  
  96. (define-safe-syntax (xcase key . clauses)
  97.                     (#f . (+ ((+ atom?) . (* #f))))
  98.   (cond ((assq 'else clauses)
  99.          (syntax-error "~s expression has ~s clause~%  ~s"
  100.                        'xcase 'else `(xcase ,key ,@clauses))))
  101.   `(,(t-syntax 'case) ,key ,@clauses (else (no-op (losing-xcase)))))
  102.  
  103. (define-safe-syntax (select key . clauses)
  104.                     (#f . (+ ((| (+ #f) (! else)) . (* #f))))
  105.   (labels (((expand-select-1 keyvar clauses)
  106.             (if (atom? clauses)
  107.                 'select-fell-off-end
  108.                 (let ((clause (car clauses))
  109.                       (lose (lambda ()
  110.                               (syntax-error "bad ~s clause syntax: ~s"
  111.                                             'select
  112.                                             (car clauses)))))
  113.                   (cond ((atom? clause) (lose))
  114.                         ((list? (car clause))
  115.                          `(,(t-syntax 'if)
  116.                             (,(t-syntax 'or)
  117.                               ,@(map (lambda (k) `(eq? ,keyvar ,k))  ; equiv?
  118.                                      (car clause)))
  119.                             ,(blockify (cdr clause))
  120.                             ,(expand-select-1 keyvar (cdr clauses))
  121.                             ))
  122.                         ((eq? (car clause) 'else) (blockify (cdr clause)))
  123.                         (else (lose)))))))
  124.           (let ((keyvar (generate-symbol 'select)))
  125.             `((,(t-syntax 'lambda) (,keyvar)
  126.                 ,(expand-select-1 keyvar clauses))
  127.               ,key))))
  128.  
  129. (define-safe-syntax (xselect key . clauses)
  130.                     (#f . (+ ((+ #f) . (* #f))))
  131.   (cond ((assq 'else clauses)
  132.          (syntax-error "~s expression has ~s clause~%  ~s"
  133.                        'xselect 'else `(xselect ,key ,@clauses))))
  134.   `(,(t-syntax 'select) ,key ,@clauses (else (no-op (losing-xselect)))))
  135.